home *** CD-ROM | disk | FTP | other *** search
/ POINT Software Programming / PPROG1.ISO / pascal / swag / sorting.swg / 0053_Sorting Arrays FAST.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1995-03-26  |  5.7 KB  |  154 lines
  1. Unit sorter;
  2. {┌──────────────────────────────────────────────────────────────────────────┐
  3.  │ This unit provides a tool for sorting arrays                             │
  4.  │ The array may be of any data type! all you have to do is to provide      │
  5.  │ a 'key function' by which the array elements are compared                │
  6.  │ such key functions are provided for the standard data types              │
  7.  │ You may write your own key functions in order to sort complex data types │
  8.  │ such as records, to reverse the sort order or to create multipile sort   │
  9.  │ keys for record elements.                                                │
  10.  │ Note: the key function must be compiled with $F+ (far calls on)          │
  11.  ├──────────────────────────────────────────────────────────────────────────┤
  12.  │ Written by: Erez Amir CompuServe ID: 100274,701    Fax. (+9723)517-1077  │
  13.  │ May be used freely, as long as this notice is kept!                      │
  14.  ├──────────────────────────────────────────────────────────────────────────┤
  15.  │           M O D I F I C A T I O N    H I S T O R Y                       │
  16.  │                                                                          │
  17.  │ Ver   Date        By             what                                    │
  18.  │ ---   ------      -------------- -------------------------------         │
  19.  │ 1.0   Sep-94      Erez Amir      Written, Debugged                       │
  20.  │ Add your update details here...                                          │
  21.  │                                                                          │
  22.  ├──────────────────────────────────────────────────────────────────────────┤
  23.  │ Examples:                                                                │
  24.  │    /* Simple char array */                                               │
  25.  │    Var a:array[1..m] of char                                             │
  26.  │ ->   Sort(a,n,SizeOf(a[1]),CharComp);                                    │
  27.  │                                                                          │
  28.  │    Type MyRec=Record Month,Day:integer end;                              │
  29.  │         MyRecPtr=^MyRec;                                                 │
  30.  │    Var MyArray: array[1..100] of MyRec;                                  │
  31.  │    /* have to write your oun key */                                      │
  32.  │     Function MyComp(p1,p2:Pointer):Boolean;                              │
  33.  │       Var                                                                │
  34.  │         v1:MyRecPtr absolute p1;                                         │
  35.  │         v2:MyRecPtr absolute p2;                                         │
  36.  │       Begin                                                              │
  37.  │         MyComp:=(V1^.Month>V2^.Month) or                                 │
  38.  │                 (V1^.Month=V2^.Month) and (V1^.Day=V2^.day);             │
  39.  │       End;                                                               │
  40.  │ ->   Sort(MyArray,100,SizeOf(MyRec),MyComp);                             │
  41.  └──────────────────────────────────────────────────────────────────────────┘}
  42. Interface
  43. Type
  44.   CompFunc=Function(V1,V2:Pointer):Boolean;
  45.  
  46. Procedure Sort(Var Struct;      { array of any Type }
  47.                Num,             { Number of elements }
  48.                Size:Integer;    { Size of each element ( byte ) }
  49.                Comp:CompFunc);
  50.  
  51. { Basic type compare functions }
  52. Function IntComp(I1,I2:Pointer):Boolean;   far;
  53. Function RealComp(r1,r2:Pointer):Boolean;  far;
  54. Function ByteComp(b1,b2:Pointer):Boolean;  far;
  55. Function CharComp(c1,c2:Pointer):Boolean;  far;
  56. Function StringComp(s1,s2:Pointer):Boolean;far;
  57.  
  58. Implementation
  59.  
  60. Procedure Sort{...};
  61.  
  62.   var
  63.     Temp:Pointer;
  64.     StructBase:Array[0..0] of Byte Absolute Struct;
  65.  
  66.   Function VLoc(n:integer):Pointer;
  67.     { Note that no range check is performed! }
  68.     Begin
  69.       {$R-}
  70.       VLoc:=Addr(structBase[n*Size]);
  71.       {$R+}
  72.     End;
  73.  
  74.   Procedure Swap(n1,n2:Integer);
  75.     { swap two elements }
  76.     Begin
  77.       Move(VLoc(n1)^,Temp^,Size);
  78.       Move(VLoc(n2)^,VLoc(n1)^,Size);
  79.       Move(Temp^,VLoc(n2)^,Size);
  80.     End;
  81.  
  82.   { Quick sort routine }
  83.   Procedure Qsort(l,r:Integer);
  84.     Var
  85.       i,j:Integer;
  86.       Pivot:Pointer;
  87.     Begin
  88.       i:=l;
  89.       j:=r;
  90.       GetMem(Pivot,Size);  { Hopefully, the midpoint}
  91.       Move(Vloc((L+r) div 2)^,Pivot^,Size);
  92.       Repeat
  93.         while Comp(Pivot,Vloc(i)) do inc(i);
  94.         while Comp(Vloc(J),pivot) do Dec(j);
  95.         if i<=j then
  96.           Begin
  97.             Swap(i,j);
  98.             Inc(i);
  99.             Dec(j);
  100.           End;
  101.       until i>j;
  102.       if j>l then Qsort(l,j); { recoursive call }
  103.       if i<r then Qsort(i,r);
  104.       FreeMem(Pivot,Size);
  105.     End;
  106.   begin
  107.     GetMem(Temp,Size);   { Temp is used for swap }
  108.     if num>1 then
  109.       Qsort(0,Num-1);
  110.     FreeMem(Temp,Size);
  111.   end;
  112.  
  113. Function IntComp(I1,I2:Pointer):Boolean;
  114.   Type
  115.     IntPtr=^Integer;
  116.   Var
  117.     v1:IntPtr absolute I1;
  118.     v2:IntPtr absolute I2;
  119.   Begin
  120.     IntComp:=V1^>V2^;
  121.   End;
  122. Function RealComp(r1,r2:Pointer):Boolean;
  123.   Type
  124.     RealPtr=^Real;
  125.   Var
  126.     v1:RealPtr absolute r1;
  127.     v2:RealPtr absolute r2;
  128.   Begin
  129.     RealComp:=V1^>V2^;
  130.   End;
  131. Function ByteComp(b1,b2:Pointer):Boolean;
  132.   Type
  133.     BytePtr=^Byte;
  134.   Var
  135.     v1:BytePtr absolute b1;
  136.     v2:BytePtr absolute b2;
  137.   Begin
  138.     ByteComp:=V1^>V2^;
  139.   End;
  140. Function CharComp(c1,c2:Pointer):Boolean;
  141.   Begin
  142.     CharComp:=ByteComp(c1,c2); { Byte and char are the same! }
  143.   End;
  144. Function StringComp(s1,s2:Pointer):Boolean;
  145.   Type
  146.     StringPtr=^String;
  147.   Var
  148.     v1:StringPtr absolute s1;
  149.     v2:StringPtr absolute s2;
  150.   Begin
  151.     StringComp:=V1^>V2^;
  152.   End;
  153.  
  154. end.